home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
table.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
15KB
|
590 lines
/* ******************************************************************** */
/* table.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* "hash" tables */
/* ******************************************************************** */
/*
* $Id: table.c,v 1.10 1992/01/29 13:50:50 pab Exp $
*
* $Log: table.c,v $
* Revision 1.10 1992/01/29 13:50:50 pab
* vax fix
*
* Revision 1.9 1992/01/17 22:32:50 pab
* fixed hash problemette
*
* Revision 1.8 1992/01/10 15:16:24 pab
* macroised total_hash
*
* Revision 1.7 1992/01/09 22:29:09 pab
* Fixed for low tag ints
*
* Revision 1.6 1992/01/07 22:15:46 pab
* ncc compatable, plus backtrace
*
* Revision 1.5 1992/01/05 22:48:29 pab
* Minor bug fixes, plus BSD version
*
* Revision 1.4 1991/12/22 15:14:42 pab
* Xmas revision
*
* Revision 1.3 1991/09/22 19:14:42 pab
* Fixed obvious bugs
*
* Revision 1.2 1991/09/11 12:07:48 pab
* 11/9/91 First Alpha release of modified system
*
* Revision 1.1 1991/08/12 16:50:08 pab
* Initial revision
*
* Revision 1.4 1991/02/14 11:27:51 kjp
* Boosted table efficiency by inlining eq among other stuff.
*
*/
#define KJPDBG(x)
/*
* Change Log:
* Version 1, April 1989
* Syntax fixes - JPff
* Name changes - RJB
* Fixed the copy functions - KJP ( 17/10/89 )
* Arbitrary lisp functions - KJP ( 27/9/90 )
*/
/* "Tables provide a general key to value association mechanism.
* Operationally, tables resemble hashtables, but the actual
* representation is not defined in order to permit alternative
* solutions, such as various forms of balanced trees."
* (tablep obj) -> { t | nil }
* (make-table [comparator]) -> table comparator is an "equal"
* (table-parameters table) -> multiple-value
* (tref table key) -> obj
* ((set tref) table key obj) -> nil
* (map-table table function) -> nil
*/
/* How about: a "table" is a balanced tree of some sorts: use a VECTOR
* [key, value, hash, left, right]
* and use the hash to binary chop.
*/
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "error.h"
#include "global.h"
#include "modboot.h"
#include "ngenerics.h"
#include "calls.h"
#define TABLES_ENTRIES 11
MODULE Module_tables;
LispObject Module_tables_values[TABLES_ENTRIES];
#define TKEY(node) vref((node),0)
#define TVALUE(node) vref((node),1)
#define THASH(node) intval(vref((node),2))
#define TLEFT(node) vref((node),3)
#define TRIGHT(node) vref((node),4)
#define total_hash(x) (is_symbol(x)? x->SYMBOL.hash: total_hash_fn(x))
/* Comparison with optimisation */
#define TCOMPARE(tab,k1,k2) \
(tab->comparator == Fn_eq \
? k1 == k2 \
: (tab->comparator == NULL \
? EUCALL_3(apply2,tab->lisp_comparator,k1,k2) != nil \
: EUCALL_2((*(tab->comparator)),k1,k2) != nil))
/* slow but fun hash from gdbm */
int
hash (char *dptr)
{
int value; /* Used to compute the hash value. */
int index; /* Used to cycle through random values. */
/* Set the initial value from key. */
value = 0x238F13AF;
for (index = 0; index<10&&dptr[index]!='\0'; index++)
value = (value + (dptr[index] << (index*5 % 24))) & 0x7FFFFFFF;
value = (1103515243 * value + 12345) & 0x7FFFFFFF;
/* Return the value. */
return value;
}
static int total_hash_fn(LispObject x)
{
switch (typeof(x)) {
case TYPE_CLASS:
x=x->CLASS.name; /* and fall through */
case TYPE_SYMBOL:
return x->SYMBOL.hash;
case TYPE_INT:
return(intval(x));
case TYPE_FLOAT:
return((int) (x->FLOAT.fvalue));
}
/* No dice - linear search */
return(0);
}
EUFUN_1( Fn_tablep, x)
{
if (is_table(x)) return lisptrue;
return nil;
}
EUFUN_CLOSE
extern LispObject Gf_equal(LispObject*);
EUFUN_1( Fn_make_table, forms)
{
extern LispObject function_eq;
struct table_structure* new_table;
if (forms == nil)
new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
else {
LispObject fn;
fn = CAR(forms);
if (fn == function_eq)
new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
else {
new_table = &allocate_table(stacktop,NULL)->TABLE;
new_table->lisp_comparator = CAR(ARG_0(stackbase));
}
}
return((LispObject) new_table);
}
EUFUN_CLOSE
/* temporary while we work out multiple values */
LispObject table_params_kludge;
void cons_up_table_params(LispObject *stacktop, LispObject table)
{
top:
if (null(table)) return;
cons_up_table_params(stacktop,TLEFT(table));
EUCALLSET_2(table_params_kludge,Fn_cons, TVALUE(table), table_params_kludge);
table = TRIGHT(table);
goto top;
}
extern void cons_up_table_keys(LispObject*,LispObject);
void cons_up_table_keys(LispObject *stacktop, LispObject table)
{
top:
if (null(table)) return;
STACK_TMP(table);
cons_up_table_keys(stacktop,TLEFT(table));
UNSTACK_TMP(table);
STACK_TMP(table);
EUCALLSET_2(table_params_kludge,Fn_cons, TKEY(table), table_params_kludge);
UNSTACK_TMP(table);
table = TRIGHT(table);
goto top;
}
/* return a multiple value of all the values in the table */
EUFUN_1( Fn_table_parameters, table)
{
while (!is_table(table))
table = CallError(stacktop,"table-parameters: ~a is not a table", table,
CONTINUABLE);
table_params_kludge = nil;
cons_up_table_params(stacktop,table->TABLE.tree);
return table_params_kludge;
}
EUFUN_CLOSE
/* Usefull ?? */
EUFUN_1( Fn_table_keys, table)
{
if (table == nil) return(nil); /* HACK !! */
table_params_kludge = nil;
cons_up_table_keys(stacktop,table->TABLE.tree);
return table_params_kludge;
}
EUFUN_CLOSE
/* Look for key in table. Return nil if not found */
static LispObject traverse_table(LispObject *stacktop, struct table_structure* table,
LispObject key)
{
LispObject node = nil;
int hashval;
hashval = total_hash(key);
node = table->tree;
do {
if (null(node)) { /* end of tree - key not found */
return nil;
}
if (TCOMPARE(table,TKEY(node),key)) {
return TVALUE(node);
}
if (hashval < THASH(node)) node = TLEFT(node);
else node = TRIGHT(node);
} while (TRUE);
return(nil);
}
static LispObject traverse_eq_table(LispObject *stacktop, struct table_structure* table,
LispObject key)
{
LispObject node = nil;
int hashval;
hashval = total_hash(key);
node = table->tree;
do {
if (null(node)) { /* end of tree - key not found */
return nil;
}
if (TKEY(node)==key) {
return TVALUE(node);
}
if (hashval < THASH(node)) node = TLEFT(node);
else node = TRIGHT(node);
} while (TRUE);
return(nil);
}
EUFUN_2( Fn_tref, table, key)
{
LispObject ans;
while (!is_table(table))
table = CallError(stacktop,"tref: ~a is not a table", table, CONTINUABLE);
if (table->TABLE.comparator == Fn_eq)
ans = traverse_eq_table(stacktop, (struct table_structure*) table, key);
else
ans = traverse_table(stacktop, (struct table_structure*)table, key);
return ans;
}
EUFUN_CLOSE
LispObject insert_tree(LispObject *stacktop,struct table_structure* table,
LispObject key, LispObject value)
{
LispObject node = nil, prev = nil;
int hashval, direction = 0;
hashval = total_hash(key);
node = table->tree;
STACK_TMPV(table);
STACK_TMP(prev);
do {
if (null(node))
{ /* new node */
LispObject tmp;
STACK_TMP(value); STACK_TMP(key);
node = (LispObject)allocate_vector(stacktop,5);
UNSTACK_TMP(key); TKEY(node) = key;
UNSTACK_TMP(value); TVALUE(node) = value;
STACK_TMP(node);
tmp = allocate_integer(stacktop,hashval); /* room for int */
UNSTACK_TMP(node);
vref(node,2)=tmp;
TLEFT(node) = nil;
TRIGHT(node) = nil;
UNSTACK_TMP(prev);
if (prev == nil)
{ /* new tree */
UNSTACK_TMP(tmp);
table= &tmp->TABLE;
table->tree = node;
return nil;
}
STACK_TMP(prev);
if (direction == 1)
{ /* should balance here */
TRIGHT(prev) = node;
}
else
{
TLEFT(prev) = node;
}
return nil;
}
if (hashval == THASH(node) && TCOMPARE(table,TKEY(node),key)) {
LispObject old = TVALUE(node);
TVALUE(node) = value;
return old;
}
UNSTACK_TMP(prev);
prev = node;
STACK_TMP(prev);
if (hashval < THASH(node))
{
direction = -1;
node = TLEFT(node);
}
else
{
direction = 1;
node = TRIGHT(node);
}
} while (TRUE);
return(nil);
}
EUFUN_3( tref_updator, table, key, value)
{
LispObject old;
KJPDBG( fprintf( stderr, "\n'tref_updator' with table %lX ", table ) );
while(!is_table(table))
table = CallError(stacktop,
"tref-updator: ~a is not a table", table, CONTINUABLE);
key = ARG_1(stackbase); value = ARG_2(stackbase);
old = insert_tree(stacktop, (struct table_structure*)table, key, value);
return old;
}
EUFUN_CLOSE
EUFUN_2( map_table, node, proc)
{
/* proc was stacked by Fn_map_table, and node is accessible through
* the table. Thus this function should only be called from Fn_map_table.
*/
if (!null(TLEFT(node)))
EUCALL_2(map_table,TLEFT(node), proc);
proc = ARG_1(stackbase);
node = ARG_0(stackbase);
EUCALL_3(apply2,proc,TKEY(node),TVALUE(node));
proc = ARG_1(stackbase);
node = ARG_0(stackbase);
stacktop = stackbase;
if (!null(TRIGHT(node)))
EUCALL_2(map_table, TRIGHT(node), proc);
return nil;
}
EUFUN_CLOSE
EUFUN_2( Fn_map_table, proc, table)
{
LispObject node = nil;
while (!is_table(table))
table = CallError(stacktop,
"map-table: ~a is not a table", table, CONTINUABLE);
ARG_1(stackbase) = table;
proc = ARG_0(stackbase);
while (!is_function(proc))
proc = CallError(stacktop,
"map-table: ~a is not a function", proc, CONTINUABLE);
table = ARG_1(stackbase);
node = (table->TABLE).tree;
if (!null(node)) {
STACK_TMP(node);
EUCALL_3(apply2,ARG_0(stackbase)/*proc*/,TKEY(node),TVALUE(node));
UNSTACK_TMP(node);
STACK_TMP(node);
if (!null(TLEFT(node)))
EUCALL_2(map_table, TLEFT(node), ARG_0(stackbase)/*proc*/);
UNSTACK_TMP(node);
if (!null(TRIGHT(node)))
EUCALL_2(map_table, TRIGHT(node), ARG_0(stackbase)/*proc*/);
}
return nil;
}
EUFUN_CLOSE
void table_copy_aux(LispObject *stacktop, LispObject node, LispObject new)
{
/* LispObject node; */
/* node = old->TABLE.tree; */
if (!null(node)) {
fprintf(stderr, "copying ");
STACK_TMP(new);
STACK_TMP(node);
EUCALL_2(Fn_print, TKEY(node), NULL);
UNSTACK_TMP(node);
STACK_TMP(node);
EUCALL_2(Fn_print, TVALUE(node), NULL);
UNSTACK_TMP(node);
UNSTACK_TMP(new);
STACK_TMP(new);
STACK_TMP(node);
EUCALL_3(tref_updator, new, TKEY(node), TVALUE(node));
KJPDBG( fprintf( stderr, "Tref updated the new table\n" ) );
if (!null(TLEFT(node))) {
UNSTACK_TMP(node);
UNSTACK_TMP(new);
STACK_TMP(new);
STACK_TMP(node);
table_copy_aux(stacktop,TLEFT(node), new);
UNSTACK_TMP(node);
UNSTACK_TMP(new);
STACK_TMP(new);
STACK_TMP(node);
}
if (!null(TRIGHT(node))) {
UNSTACK_TMP(node);
UNSTACK_TMP(new);
table_copy_aux(stacktop,TRIGHT(node), new);
}
}
return;
}
EUFUN_1( table_copy, table)
{
LispObject ans;
ans = (LispObject) allocate_table(stacktop,table->TABLE.comparator);
ans->TABLE.lisp_comparator = table->TABLE.lisp_comparator;
table_copy_aux(stacktop,table->TABLE.tree, ans);
return ans;
}
EUFUN_CLOSE
EUFUN_1( Fn_clear_table, table)
{
while (!is_table(table))
table = CallError(stacktop,"clear-table: ~a is not a table", table,
CONTINUABLE);
table->TABLE.tree = nil;
return table;
}
EUFUN_CLOSE
/* This function is not used by anyone!!!
void put_table(LispObject *stacktop, LispObject tab1, LispObject tab2 )
{
if ( tab1 == nil )
return;
else
table_copy_aux(stacktop,tab1->TABLE.tree, tab2);
}
*/
LispObject sym_table_copy;
/* Printing... */
EUFUN_2( Md_generic_prin_Table, tab, stream)
{
extern LispObject Gf_generic_prin(LispObject*);
if (!is_stream(stream))
CallError(stacktop,
"generic-prin: non-stream argument",stream,NONCONTINUABLE);
/* We assume the table's what it claims to be... */
if (tab->TABLE.comparator == NULL) {
fprintf(stream->STREAM.handle,"#T(comparator: ");
EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
stream = ARG_1(stackbase);
fprintf(stream->STREAM.handle,")");
}
else {
if (tab->TABLE.comparator == Fn_eq)
fprintf(stream->STREAM.handle,"#T(eq)");
else
fprintf(stream->STREAM.handle,"#T(equal)");
}
return(tab);
}
EUFUN_CLOSE
/* Writing... */
EUFUN_2( Md_generic_write_Table, tab, stream)
{
extern LispObject Gf_generic_prin(LispObject*);
if (!is_stream(stream))
CallError(stacktop,
"generic-write: non-stream argument",stream,NONCONTINUABLE);
/* We assume the table's what it claims to be... */
if (tab->TABLE.comparator == NULL) {
fprintf(stream->STREAM.handle,"#T(comparator: ");
EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
stream = ARG_1(stackbase);
fprintf(stream->STREAM.handle,")");
}
else {
if (tab->TABLE.comparator == Fn_eq)
fprintf(stream->STREAM.handle,"#T(eq)");
else
fprintf(stream->STREAM.handle,"#T(equal)");
}
return(tab);
}
EUFUN_CLOSE
void initialise_tables(LispObject *stacktop)
{
extern LispObject generic_generic_prin;
extern LispObject generic_generic_write;
LispObject fun, upd;
open_module(stacktop,
&Module_tables,
Module_tables_values,
"tables",
TABLES_ENTRIES);
(void) make_module_function(stacktop,"tablep",Fn_tablep,1);
(void) make_module_function(stacktop,"make-table",Fn_make_table,-1);
(void) make_module_function(stacktop,"table-parameters",Fn_table_parameters,1);
fun = make_module_function(stacktop,"table-ref",Fn_tref,2);
STACK_TMP(fun);
upd = make_unexported_module_function(stacktop,"table-ref-updator", tref_updator, 3);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun, upd);
(void) make_module_function(stacktop,"map-table",Fn_map_table,2);
sym_table_copy = make_module_function(stacktop,"copy-table", table_copy, 1);
add_root(&sym_table_copy);
sym_table_copy = sym_table_copy->SYMBOL.lvalue;
add_root(&sym_table_copy);
(void) make_module_function(stacktop,"table-keys",Fn_table_keys,1);
(void) make_module_function(stacktop,"clear-table",Fn_clear_table,1);
make_module_function(stacktop,"generic_generic_prin,Table",Md_generic_prin_Table,2);
make_module_function(stacktop,"generic_generic_write,Table",Md_generic_write_Table,2);
close_module();
}